home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / PowerLisp 2.01 / PowerLisp 2.01 ƒ / Library / setf.lisp < prev    next >
Encoding:
Text File  |  1996-05-20  |  5.3 KB  |  196 lines  |  [TEXT/ROSA]
  1. ;;;
  2. ;;;        PowerLisp 2.0
  3. ;;;        Copyright © 1996 Roger Corman.  All rights reserved.
  4. ;;;
  5. ;;;
  6. ;;;        Common Lisp 'setf' macro.
  7. ;;;
  8.  
  9. (in-package :common-lisp)
  10. (provide :setf)
  11.  
  12. (export '(    fboundp
  13.             fdefinition
  14.             fmakunbound
  15.             print-unreadable-object
  16.             setf
  17.             defsetf))
  18.  
  19. (defun setf-function-symbol (function-specifier)
  20.   (if (consp function-specifier)
  21.       (let ((print-name (format nil "~:@(~A~)" function-specifier)))
  22.         (intern print-name
  23.                 (symbol-package (cadr function-specifier))))
  24.       function-specifier))
  25.  
  26. (defmacro setf (&rest forms)
  27.     (let ((form-list nil))
  28.         (do* ((f forms (cddr f))
  29.               (place (car f) (car f))
  30.               (value (cadr f) (cadr f)))
  31.             ((null f))
  32.             (if (null (cdr f)) (error "Odd number of arguments to setf: ~A" forms))
  33.             (if (symbolp place)
  34.                 (setq form-list (cons `(setq ,place ,value) form-list))
  35.                 (let ((expansion-func (get (car place) 'cl::_setf_expansion_)))
  36.                     (if (symbolp expansion-func)
  37.                         (setq form-list (cons `(,expansion-func ,value ,@(cdr place)) form-list))
  38.                         (setq form-list (cons `(funcall ,expansion-func ,value ,@(cdr place)) form-list))))))
  39.         (if (cdr form-list)
  40.             `(progn ,@(nreverse form-list))
  41.             (car form-list))))
  42.  
  43. ;;
  44. ;;    Common Lisp 'defun' macro.
  45. ;;    This redefines the built-in special form.
  46. ;;
  47. (defmacro defun (name lambda-list &rest forms)
  48.     (let ((doc-form nil) 
  49.           (lambda-form nil) 
  50.           (declarations nil)
  51.           (setf-form nil))
  52.  
  53.         (if (and (consp name) (eq (car name) 'setf))
  54.             (progn
  55.                 (unless (symbolp (cadr name)) (error "Invalid function name: ~A" name))
  56.                 (setq setf-form (cadr name))
  57.                 (setq name (setf-function-symbol name))))
  58.  
  59.         ;; look for declarations and doc string
  60.         (do* ((f forms (cdr f)))
  61.             ((null f) (setq forms f))
  62.             (if (and (typep (car f) 'string) (null doc-form) (cdr f))
  63.                 (setq doc-form 
  64.                     `((setf (documentation ',name 'function) ,(car f))))
  65.                 (if (and (consp (car f)) (eq (caar f) 'declare))
  66.                     (push (car f) declarations)
  67.                     (progn (setq forms f) (return)))))
  68.  
  69.         (setq lambda-form 
  70.             `(lambda ,lambda-list ,@(nreverse declarations)
  71.                 (block ,name ,@forms)))
  72.         
  73.         (if setf-form         
  74.             `(progn
  75.                 ,@doc-form
  76.                 (setf (symbol-function ',name) (function ,lambda-form))
  77.                 (setf (get ',setf-form 'cl::_setf_expansion_) ',name)
  78.                 ',name) 
  79.             `(progn
  80.                 ,@doc-form
  81.                 (setf (symbol-function ',name) (function ,lambda-form))
  82.                 ',name))))
  83.  
  84. ;;
  85. ;;    Common Lisp 'defmacro' macro.
  86. ;;    This redefines the built-in special form.
  87. ;;
  88. (defmacro defmacro (name lambda-list &rest forms)
  89.     (let ((doc-form nil) 
  90.           (lambda-form nil)
  91.           (declarations nil))
  92.  
  93.         ;; look for declarations and doc string
  94.         (do* ((f forms (cdr f)))
  95.             ((null f) (setq forms f))
  96.             (if (and (typep (car f) 'string) (null doc-form) (cdr f))
  97.                 (setq doc-form 
  98.                     `((setf (documentation ',name 'macro) ,(car f))))
  99.                 (if (and (consp (car f)) (eq (caar f) 'declare))
  100.                     (push (car f) declarations)
  101.                     (progn (setq forms f) (return)))))
  102.  
  103.         (setq lambda-form 
  104.             `(lambda (form &optional env) 
  105.                 (destructuring-bind ,lambda-list 
  106.                     (cdr form)
  107.                     ,@(nreverse declarations) 
  108.                     (block ,name ,@forms)))) 
  109.         `(progn
  110.             ,@doc-form
  111.             (setf (macro-function ',name) (function ,lambda-form))
  112.             ',name))) 
  113.  
  114. (defun apply-arg-rotate (f args) 
  115.     (apply f (car (last args)) (butlast args)))
  116.  
  117. (defmacro defsetf (sym first &rest rest)
  118.     (if (symbolp first)
  119.         `(progn (cl::putprop ',sym 'cl::_setf_expansion_ ',first) ',sym)
  120.         (let ((f `#'(lambda ,(append (car rest) first) ,@(cdr rest)))
  121.             (args (gensym)))
  122.             `(progn
  123.                 (setf (get ',sym 'cl::_setf_expansion_)
  124.                     #'(lambda (&rest ,args) (apply-arg-rotate ,f ,args)))
  125.                 ',sym))))
  126.  
  127. (defun fboundp (function-specifier)
  128.   (if (consp function-specifier)
  129.       (%fboundp (get (cadr function-specifier) '_setf_expansion_))
  130.       (%fboundp function-specifier)))
  131.  
  132. (defun fdefinition (function-specifier)
  133.       (if (consp function-specifier)
  134.       (symbol-function (get (cadr function-specifier) 'cl::_setf_expansion_))
  135.       (symbol-function function-specifier)))
  136.  
  137. (defun (setf fdefinition) (value function-specifier)
  138.       (if (consp function-specifier)
  139.         (let* ((func (cadr function-specifier))
  140.                (set-sym (get func 'cl::_setf_expansion_)))
  141.             (unless set-sym
  142.                 (progn
  143.                     (setq set-sym (setf-function-symbol function-specifier))
  144.                     (setf (get func 'cl::_setf_expansion_) set-sym)))
  145.             (setf (symbol-function set-sym) value))
  146.         (setf (symbol-function function-specifier) value)))
  147.         
  148. (defun fmakunbound (function-specifier)
  149.   (if (consp function-specifier)
  150.       (%fmakunbound (get (cadr function-specifier) 'cl::_setf_expansion_))
  151.       (%fmakunbound function-specifier)))
  152.  
  153. ;;; print-unreadable-object is the standard way in the new Common Lisp
  154. ;;; to generate #< > around objects that can't be read back in.  The option
  155. ;;; (:identity t) causes the inclusion of a representation of the object's
  156. ;;;  identity, typically some sort of machine-dependent storage address.
  157.  
  158. (defmacro print-unreadable-object
  159.           ((object stream &key type identity) &body body)
  160.   `(let ((.stream. ,stream)
  161.          (.object. ,object))
  162.      (format .stream. "#<")
  163.      ,(when type
  164.         '(format .stream. "~S" (type-of .object.)))
  165.      ,(when (and type (or body identity))
  166.         '(format .stream. " "))
  167.      ,@body
  168.      ,(when (and identity body)
  169.         '(format .stream. " "))
  170.      ,(when identity
  171.              '(format .stream. "#x~X" (pl::address .object.))
  172.        )
  173.      (format .stream. ">")
  174.      nil))
  175.     
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  
  196.